home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / tool+ / popUp7 < prev    next >
Encoding:
Text File  |  1996-02-27  |  6.0 KB  |  208 lines  |  [TEXT/MACA]
  1. need ctl
  2.  
  3. :CLASS popUps <super Control 4 <indexed
  4.  
  5. \ late bound for subclasses to work - note that there can be no instances
  6. \  of this class..otherwise HANDLE: is recursive
  7.     :M  HANDLE: handle: [ ^base ] ;M
  8.  
  9.     :M  CTLHANDLE: get: ctlhndl ;M
  10.  
  11.     :M  GETCTLTITLE: ( -- addr len) ^base getTitle: control ;M
  12.  
  13.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  14.     :M  PUT:   put: resId  ^base put: array  ;M
  15.  
  16.     :M  PUTITEM: put: super ;M
  17.  
  18.     :M  GETITEM: ( -- item) get: super ;M
  19.  
  20.     :M  EXEC: ( part# --)
  21.         IF   getItem: self -> mitem
  22.                ^base -> theMenu get: resID -> menuID
  23.             mitem -dup IF 1- at: self execute exec: action THEN
  24.             get: super put: myValue
  25.         THEN ;M
  26.  
  27.     \ ( item# -- addr len )  get string for item #
  28.     :M  GET:  ( item -- addr len ) handle: self  swap makeInt
  29.         buf255 +base  call GetItem  buf255 count ;M
  30.  
  31.     :M  GETTITLE: ( -- addr len) handle: self >ptr 14 + count ;M
  32.  
  33.     :M  GETNAME: ( -- addr len) getItem: self get: self ;M
  34.  
  35.     :M  GETMAXVAL: ( -- n) word0 ctlHandle: self call getCtlMax i->l ;M
  36.     :M  SETMAXVAL: ( n __) ctlHandle: self swap makeint call setCtlMax ;M
  37.  
  38.     \ ( addr len -- )  Append a menu item
  39.     :M  ADD:   Str255  handle: self ?new swap  call AppendMenu
  40.         getMaxVal: self 1+ setMaxVal: self ;M
  41.  
  42.     \ ( ind --) remove a menu item
  43.     :M  REMOVE: ( ind --) handle: self swap makeint call delMenuItem
  44.         getMaxVal: self 1- setMaxVal: self ;M
  45.  
  46.     :M  DELETE: remove: self ;M
  47.  
  48.     \ ( addr len item# -- )  replace menu item string, but don't redraw
  49.     :M  (SET): alive: [ obj: myWindow ]
  50.         IF >r str255 >r handle: self ?new
  51.             r> r> swap >r makeInt r> call SetItem
  52.         ELSE 2drop drop
  53.         THEN ;M
  54.  
  55.     \ ( addr len item# -- )  replace menu item string and draw menu
  56.     :M  SET:  (set): self alive: [ obj: myWindow ]
  57.         IF  draw: super THEN ;M
  58.  
  59.     :M  INSERTITEM: { addr len item# -- }
  60.         handle: self addr len str255 item# makeint call InsMenuItem draw: self ;M
  61.  
  62.     :M  (REDRAW): ( item --) dup 0= swap getItem: self = or IF draw: [ obj: myWindow ] THEN ;M
  63.  
  64.     \ ( item# -- )  Enable a menu item
  65.     :M  ENABLE: { item -- } handle: self item makeInt call EnableItem
  66.         item (redraw): self ;M
  67.  
  68.     \ ( item# -- )  Grey and disable an item
  69.     :M  DISABLE: { item -- } handle: self item makeInt call DisableItem
  70.         item (redraw): self ;M
  71.  
  72. \ return the number of items in the menu
  73.     :M  MITEMS: word0 handle: self call countMItems i->l ;M
  74.  
  75.     :M  CHECKED?: ( item -- b) ^base get: control = ;M
  76.  
  77.     :M  CLASSINIT: nullcfa fill: super nullcfa put: action ;M
  78.  
  79. ;CLASS
  80.  
  81.  
  82. :CLASS popUpMenu <super popUps
  83.  
  84.     rect bounds
  85.     int    valueParm
  86.  
  87.     :M  HANDLE: ptr: ctlhndl 28 + @ -base @ -base @ ;M
  88.  
  89.     :M  PUTRECT: put: bounds ;M
  90.  
  91. \ *** next three methods apply to the Title box, not the popup ***
  92.  
  93. \ 0=left;1=center;255=right
  94.     :M  JUSTIFY: ( n --) get: valueParm $ ff00 and or put: valueParm ;M
  95.  
  96. \ $100=bold;$200=italic;$400=underline;$800=outline;$1000=shadow
  97.     :M FACE: ( n --) get: valueParm $ e0ff and or put: valueParm ;M
  98.  
  99. \ $2000=condense;$4000=extend;$8000=nostyle
  100.     :M STYLE: ( n --) get: valueParm $ 1fff and or put: valueParm ;M
  101.  
  102. \ build a popup; procid is set to 1=fixedwidth;4=addresmen;8=useWFont
  103.     :M  NEW:  { x y addr len theWind \ tWid -- }
  104.         theWind saveFont
  105.         get: procID 8 and 0=
  106.         IF 0 tFont 12 tSize THEN addr len tWidth -> tWid    \ width of title
  107.         0 abs: theWind  Abs: bounds addr len str255
  108.         w 256 int: valueParm int: resId twid makeint  1008 get: procId +
  109.         makeInt  ^base
  110.         call NewControl put: ctlhndl
  111.         ^base get: ctlhndl set-ctl-obj
  112.         theWind put: myWindow theWind restFont ;M
  113.  
  114.       :M  GETNEW: { \ theWind -- } get: myWindow -> theWind
  115.          theWind 0= classerr" 190 theWind saveFont
  116.          0 int: resID theWind +base call getNewControl dup 0= classerr" 170
  117.          put: ctlhndl
  118.         ^base get: ctlhndl set-ctl-obj
  119.         get: myValue ^base put: control theWind restFont ;M
  120.  
  121. ;CLASS
  122.  
  123.  
  124. \ Example:
  125. \ ctlwind suz
  126. \ " .rsrc" openresfile
  127. \ 
  128. \ 5 popupmenu bob
  129. \ 100 50 160 69 putrect: bob
  130. \ 128 putresid: bob 8 init: bob
  131. \ example: suz
  132. \ 100 50 " myTitle:" suz new: bob
  133. \ 
  134. \ : one mitem home . ;
  135. \ 'c one fill: bob
  136. \ NB. When using PopUpDlgMenus in SaveDlg objects, know that the fill:
  137. \   method does not fill the instance variable 'myValue' of the control
  138. \   object. This means that even though the popup looks correct, if the
  139. \   user doesn't click in the menu, the ivar will not be filled. So access
  140. \   of the popup value by the getItem: method after the dialog is closed
  141. \   will not yield the correct number. For right now, must initialize each
  142. \   popup to the stored value of the saveDlg parameters by hand.
  143.  
  144. :CLASS popUpDlgMenu <super popUps
  145.  
  146.     int itemNo
  147.  
  148.     :M ITEMNo:     ( -- n)    get: itemNo ;M
  149.     :M PUTITEMNo: ( n --) put: itemNo ;M
  150.  
  151. \ returns handle to the control object, not the menu
  152. \ also, be careful...need to putItemNo: at compile time
  153.     :M CTLHANDLE: ( -- hndl) get: itemNo dup 0= classerr" 191
  154.         handle: [ obj: myWindow ] dup put: ctlhndl ;M
  155.  
  156.     :M PUTITEM: ( -- n) alive: [ obj: myWindow ]
  157.         IF ctlHandle: self swap makeint call SetCtlValue
  158.         ELSE put: myValue
  159.         THEN ;M
  160.  
  161.     :M HANDLE: ctlHandle: self >ptr 28 + @ -base @ -base @ ;M
  162.  
  163.     :M EXECACTION: handle: self drop get: itemNo get: [ obj: myWindow ] putItem: self
  164.         true exec: self returnToModal ;M
  165.  
  166.     :M SETITEM: ( --) ctlHandle: self drop getItem: self putItem: self ;M
  167.  
  168.     :M  GETNAME: { \ myMenu -- addr len } alive: [ obj: myWindow ]
  169.         IF setItem: self getItem: self get: self
  170.         ELSE 1 heap> menu -> myMenu get: resID putResID: myMenu getnew: myMenu
  171.             get: myValue get: myMenu
  172.             str255 -base count
  173.             release: myMenu dispose> myMenu
  174.         THEN ;M
  175.  
  176. ;CLASS
  177.  
  178. \ Example:
  179. \ 3 savedlg bob1
  180. \ 402 putresid: bob1
  181. \ " .rsrc" openresfile
  182. \ 
  183. \ 5 popUpDlgMenu suz1
  184. \ 402 putresid: suz1
  185. \ bob1 putWindow: suz1
  186. \ 
  187. \ 2 putItemNo: suz1
  188. \ 
  189. \ : uu " .rsrc" openresfile getnew: bob1 modal: bob1 ;
  190. \ 
  191. \ 'c returnToModal 2 to: bob1
  192. \ 
  193. \ 0 value huh
  194. \ : ll handle: suz1 drop get: theItem get: bob1 putItem: suz1
  195. \     true exec: suz1 returnToModal ;
  196. \ : ll execAction: suz1 ;
  197. \ : dosave save: bob1 closer ;
  198. \ 'c dosave 1 to: bob1
  199. \ 'c ll 2 to: bob1
  200. \ 
  201. \ : one1 1 ++> huh ;
  202. \ : two 2 ++> huh ;
  203. \ : three 3 ++> huh ;
  204. \ : four 4 ++> huh ;
  205. \ : five 5 ++> huh ;
  206. \ 
  207. \ 5 'cfas one1 two three four five 400 put: suz1
  208.